Developer CD Series 1998 May: Tool Chest/Dev.CD May 98 TC.toast/Tool Chest/Development Kits/HyperCard Related/APDA HyperCard Toolkits/HyperCard CTB Toolkit 1.0b2/Source Code/CTBFileTransfer.p

Text File | 1995-02-07 | 4.9 KB | 163 lines | [TEXT/MPS ]

(*
    CTBFileTransfer(direction[,fileName]) -- Transfer a file. The direction parameter specified the
        transfer direction ("send" or "receive"). The fileName parameter specifies the file to be sent
        or received; if it is absent or empty, then the user is queried for the file name. Return the
        name of the file actually sent or received.

    To compile and link this file using Macintosh Programmer's Workshop,

        pascal -w CTBFileTransfer.p
        link -m ENTRYPOINT -o HyperCommands -rt XFCN=2764 -sn Main=CTBFileTransfer ∂
            CTBFileTransfer.p.o "{MPW}"Libraries:interface.o "{MPW}"Libraries:Libraries:HyperXLib.o

    © Copyright 1990 by Apple Computer, Inc.

    Initial coding 2/90 by Harry R. Chesley.
*)

{$R-}

{$S CTBFileTransfer }     { Segment name must be the same as the command name. }

unit DummyUnit;

interface

uses MemTypes, QuickDraw, OSIntf, ToolIntf, CTBUtils, FTIntf, CMIntf, TMIntf, CRMIntf, HyperXCmd;

procedure EntryPoint(paramPtr: XCmdPtr);

implementation

procedure CTBFileTransfer(paramPtr: XCmdPtr); forward;

function sendProc(thePtr: Ptr; theSize: longInt; refCon: longInt; channel: CMChannel;
                                flags: integer): longInt; forward;

function recvProc(thePtr: Ptr; theSize: longInt; refCon: longInt; channel: CMChannel;
                                var flags: CMFlags): longInt; forward;

function environsProc(refCon: longInt; var theEnvirons: ConnEnvironRec): CMErr; forward;

procedure EntryPoint(paramPtr: XCmdPtr);

    begin
        CTBFileTransfer(paramPtr);
    end;

procedure CTBFileTransfer(paramPtr: XCmdPtr);

    {$I CTBUtil.inc}

    var i, j: integer;
        ch: Char;
        sendIt: boolean;
        ft: FTHandle;
        where: Point;
        f: SFReply;
        tl: SFTypeList;
        s: Str255;
        p: Ptr;

    procedure Fail(errMsg: Str255); { set theResult and quit }
        begin
            paramPtr^.returnValue := PasToZero(paramPtr,errMsg);
            exit(CTBFileTransfer);
        end;

    begin
        { Check the parameter count. }
        i := paramPtr^.paramCount;
        if (i = 0) or (i > 2) then Fail('Invalid parameter count');

        { Check that the Comm Toolbox is here. }
        CTBReady;
        { And there's a connection tool. }
        EnsurePresent(connectionTool);
        { And a file transfer tool. }
        EnsurePresent(fileTransferTool);
        { And the connection is open. }
        EnsureOpen;

        { Figure out if we're sending or receiving. }
        ch := Chr(paramPtr^.params[1]^^);
        if (ch = 's') or (ch = 'S') then sendIt := true
        else sendIt := false;

        { Get the file name. }
        if ParmPresent(2) then
            begin
                { Get it from the input parameter. }
                GetStrParm(2,s);
                if length(s) > 63 then Fail('File name too long');
                f.vRefNum := 0;
                f.version := 0;
                f.fName := s;
            end
        else
            begin
                { Get it from the user. }
                where.h := 10; where.v := 40;
                if sendIt then SFGetFile(where,'File to send:',nil,-1,tl,nil,f)
                else SFPutFile(where,'File to receive:','file name',nil,f);
                if not f.good then Fail('User cancel');
            end;

        { Open a new tool, so we can set the send/recv/environs proc pointers. Note: In theory, this
            could be done by reaching into the connection tools handle and changing the ProcPtrs
            ourselves (the CTB people tell me it's OK), but I just can't bring myself to do that... This way
            everything'll work in the future regardless of what changes internally, and it really isn't
            all that inefficient, if you think about how many file transfers per second most people do... }
        ft := FTNew(Globals^^.FTHand^^.procID,ftNoMenus+ftQuiet,@sendProc,@recvProc,nil,nil,
                                                        @environsProc,nil,ord4(Globals^^.connHand),0);
        p := FTGetConfig(Globals^^.FTHand);
        j := FTSetConfig(ft,p);
        DisposPtr(p);

        { Do the file transfer. Note: some user feedback really ought to be added here. }
        if sendIt then FailOSErr(FTStart(ft,ftTransmitting,f))
        else FailOSErr(FTStart(ft,ftReceiving,f));
        while BAnd(ft^^.flags,ftIsFTMode) <> 0 do FTExec(ft);

        { Remember the file name. }
        s := ft^^.theReply.fName;

        { Dispose of the file transfer tool we just created. }
        FTDispose(ft);

        { Return the file name. }
        paramPtr^.returnValue := PasToZero(paramPtr,s);
    end;

function sendProc(thePtr: Ptr; theSize: longInt; refCon: longInt; channel: CMChannel;
                                flags: integer): longInt;
    { Send a block for the file transfer tool. }

    begin
        { Send it to the connection tool in the refCon. }
        sendProc := 0;
        if CMWrite(ConnHandle(refCon),thePtr,theSize,channel,false,nil,0,flags) = noErr then
            sendProc := theSize;
    end;

function recvProc(thePtr: Ptr; theSize: longInt; refCon: longInt; channel: CMChannel;
                                var flags: CMFlags): longInt;
    { Receive a block for the file transfer tool. }

    begin
        { Receive it from the connection tool in the refCon. }
        recvProc := 0;
        if CMRead(ConnHandle(refCon),thePtr,theSize,channel,false,nil,0,flags) = noErr then
            recvProc := theSize;
    end;

function environsProc(refCon: longInt; var theEnvirons: ConnEnvironRec): CMErr;
    { Get the environment information for the file transfer tool. }

    begin
        { Query the connection tool in the refCon for it. }
        environsProc := CMGetConnEnvirons(ConnHandle(refCon),theEnvirons);
    end;

end.